library("tidyverse"); theme_set(theme_bw())
## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.2 ──
## ✔ ggplot2 3.4.0 ✔ purrr 0.3.4
## ✔ tibble 3.1.8 ✔ dplyr 1.0.10
## ✔ tidyr 1.2.1 ✔ stringr 1.4.1
## ✔ readr 2.1.2 ✔ forcats 0.5.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
library("Sleuth3")
# Tables
library("DT")
## Warning: package 'DT' was built under R version 4.2.3
library("knitr") # for kable
library("kableExtra")
## Warning: package 'kableExtra' was built under R version 4.2.3
##
## Attaching package: 'kableExtra'
##
## The following object is masked from 'package:dplyr':
##
## group_rows
library("formattable")
## Warning: package 'formattable' was built under R version 4.2.3
# Figures
library("scales")
##
## Attaching package: 'scales'
##
## The following objects are masked from 'package:formattable':
##
## comma, percent, scientific
##
## The following object is masked from 'package:purrr':
##
## discard
##
## The following object is masked from 'package:readr':
##
## col_factor
library("plotly")
##
## Attaching package: 'plotly'
##
## The following object is masked from 'package:formattable':
##
## style
##
## The following object is masked from 'package:ggplot2':
##
## last_plot
##
## The following object is masked from 'package:stats':
##
## filter
##
## The following object is masked from 'package:graphics':
##
## layout
library("leaflet")
## Warning: package 'leaflet' was built under R version 4.2.3
library("gifski")
## Warning: package 'gifski' was built under R version 4.2.3
We will take a look at the diamonds data set.
dim(diamonds)
## [1] 53940 10
As we will see later, this data is too large for interactive tables and thus we will take a random sample of these data.
The kable() function in the knitr package
provides an easy display of tables in an HTML document.
By default, the kable function will show the entire table. So, let’s just show the first few lines.
d <- diamonds %>%
group_by(cut) %>% # ensure we have all cuts for grouping
sample_n(3)
Also, by default, the table looks pretty bad, so let’s add some styling.
knitr::kable(d) %>%
kable_styling()
| carat | cut | color | clarity | depth | table | price | x | y | z |
|---|---|---|---|---|---|---|---|---|---|
| 0.70 | Fair | F | SI2 | 66.4 | 56 | 1564 | 5.51 | 5.42 | 3.63 |
| 2.10 | Fair | G | I1 | 64.6 | 58 | 6597 | 8.05 | 8.01 | 5.19 |
| 1.00 | Fair | E | SI2 | 65.8 | 58 | 2948 | 6.28 | 6.16 | 4.09 |
| 0.50 | Good | G | VVS2 | 63.8 | 56 | 1715 | 5.03 | 5.06 | 3.22 |
| 0.93 | Good | F | SI2 | 61.3 | 62 | 3376 | 6.17 | 6.26 | 3.81 |
| 1.00 | Good | G | VVS1 | 63.8 | 60 | 7134 | 6.35 | 6.31 | 4.04 |
| 0.31 | Very Good | F | VS1 | 60.9 | 56 | 675 | 4.37 | 4.38 | 2.66 |
| 0.40 | Very Good | D | SI2 | 61.6 | 59 | 666 | 4.68 | 4.74 | 2.90 |
| 0.70 | Very Good | E | VS1 | 63.8 | 57 | 3177 | 5.61 | 5.65 | 3.59 |
| 0.30 | Premium | H | VS1 | 63.0 | 58 | 675 | 4.28 | 4.23 | 2.68 |
| 0.40 | Premium | E | VS1 | 62.4 | 54 | 1125 | 4.75 | 4.71 | 2.95 |
| 0.30 | Premium | F | VVS2 | 61.6 | 58 | 737 | 4.28 | 4.35 | 2.66 |
| 1.00 | Ideal | D | VS1 | 62.4 | 55 | 7966 | 6.40 | 6.43 | 4.00 |
| 0.41 | Ideal | F | VVS1 | 62.0 | 55 | 1295 | 4.74 | 4.78 | 2.95 |
| 1.57 | Ideal | G | VVS2 | 62.3 | 56 | 15144 | 7.48 | 7.41 | 4.64 |
d %>%
knitr::kable(
caption = "Diamonds data",
align = c("rlllrrrrrr")
) %>%
kable_styling(bootstrap_options = c('striped', 'hover', 'condensed')) %>%
scroll_box(height = "200px")
| carat | cut | color | clarity | depth | table | price | x | y | z |
|---|---|---|---|---|---|---|---|---|---|
| 0.70 | Fair | F | SI2 | 66.4 | 56 | 1564 | 5.51 | 5.42 | 3.63 |
| 2.10 | Fair | G | I1 | 64.6 | 58 | 6597 | 8.05 | 8.01 | 5.19 |
| 1.00 | Fair | E | SI2 | 65.8 | 58 | 2948 | 6.28 | 6.16 | 4.09 |
| 0.50 | Good | G | VVS2 | 63.8 | 56 | 1715 | 5.03 | 5.06 | 3.22 |
| 0.93 | Good | F | SI2 | 61.3 | 62 | 3376 | 6.17 | 6.26 | 3.81 |
| 1.00 | Good | G | VVS1 | 63.8 | 60 | 7134 | 6.35 | 6.31 | 4.04 |
| 0.31 | Very Good | F | VS1 | 60.9 | 56 | 675 | 4.37 | 4.38 | 2.66 |
| 0.40 | Very Good | D | SI2 | 61.6 | 59 | 666 | 4.68 | 4.74 | 2.90 |
| 0.70 | Very Good | E | VS1 | 63.8 | 57 | 3177 | 5.61 | 5.65 | 3.59 |
| 0.30 | Premium | H | VS1 | 63.0 | 58 | 675 | 4.28 | 4.23 | 2.68 |
| 0.40 | Premium | E | VS1 | 62.4 | 54 | 1125 | 4.75 | 4.71 | 2.95 |
| 0.30 | Premium | F | VVS2 | 61.6 | 58 | 737 | 4.28 | 4.35 | 2.66 |
| 1.00 | Ideal | D | VS1 | 62.4 | 55 | 7966 | 6.40 | 6.43 | 4.00 |
| 0.41 | Ideal | F | VVS1 | 62.0 | 55 | 1295 | 4.74 | 4.78 | 2.95 |
| 1.57 | Ideal | G | VVS2 | 62.3 | 56 | 15144 | 7.48 | 7.41 | 4.64 |
groups <- table(d$cut)
d %>%
knitr::kable(
caption = "Diamonds data",
align = c("rlllrrrrrr")
) %>%
kable_styling(bootstrap_options = c('striped', 'hover', 'condensed')) %>%
pack_rows(
index = setNames(groups, names(groups))
)
| carat | cut | color | clarity | depth | table | price | x | y | z |
|---|---|---|---|---|---|---|---|---|---|
| Fair | |||||||||
| 0.70 | Fair | F | SI2 | 66.4 | 56 | 1564 | 5.51 | 5.42 | 3.63 |
| 2.10 | Fair | G | I1 | 64.6 | 58 | 6597 | 8.05 | 8.01 | 5.19 |
| 1.00 | Fair | E | SI2 | 65.8 | 58 | 2948 | 6.28 | 6.16 | 4.09 |
| Good | |||||||||
| 0.50 | Good | G | VVS2 | 63.8 | 56 | 1715 | 5.03 | 5.06 | 3.22 |
| 0.93 | Good | F | SI2 | 61.3 | 62 | 3376 | 6.17 | 6.26 | 3.81 |
| 1.00 | Good | G | VVS1 | 63.8 | 60 | 7134 | 6.35 | 6.31 | 4.04 |
| Very Good | |||||||||
| 0.31 | Very Good | F | VS1 | 60.9 | 56 | 675 | 4.37 | 4.38 | 2.66 |
| 0.40 | Very Good | D | SI2 | 61.6 | 59 | 666 | 4.68 | 4.74 | 2.90 |
| 0.70 | Very Good | E | VS1 | 63.8 | 57 | 3177 | 5.61 | 5.65 | 3.59 |
| Premium | |||||||||
| 0.30 | Premium | H | VS1 | 63.0 | 58 | 675 | 4.28 | 4.23 | 2.68 |
| 0.40 | Premium | E | VS1 | 62.4 | 54 | 1125 | 4.75 | 4.71 | 2.95 |
| 0.30 | Premium | F | VVS2 | 61.6 | 58 | 737 | 4.28 | 4.35 | 2.66 |
| Ideal | |||||||||
| 1.00 | Ideal | D | VS1 | 62.4 | 55 | 7966 | 6.40 | 6.43 | 4.00 |
| 0.41 | Ideal | F | VVS1 | 62.0 | 55 | 1295 | 4.74 | 4.78 | 2.95 |
| 1.57 | Ideal | G | VVS2 | 62.3 | 56 | 15144 | 7.48 | 7.41 | 4.64 |
d %>%
# Conditional highlighting
mutate(
carat = cell_spec(carat, "html", color = ifelse(carat > .7, "red", "black")),
price = cell_spec(price, "html", color = ifelse(price < 5000, "blue", "black"))
) %>%
knitr::kable(
escape = FALSE,
caption = "Diamonds data",
align = c("rlllrrrrrr")
) %>%
kable_styling(bootstrap_options = c('striped', 'hover', 'condensed'))
| carat | cut | color | clarity | depth | table | price | x | y | z |
|---|---|---|---|---|---|---|---|---|---|
| 0.7 | Fair | F | SI2 | 66.4 | 56 | 1564 | 5.51 | 5.42 | 3.63 |
| 2.1 | Fair | G | I1 | 64.6 | 58 | 6597 | 8.05 | 8.01 | 5.19 |
| 1 | Fair | E | SI2 | 65.8 | 58 | 2948 | 6.28 | 6.16 | 4.09 |
| 0.5 | Good | G | VVS2 | 63.8 | 56 | 1715 | 5.03 | 5.06 | 3.22 |
| 0.93 | Good | F | SI2 | 61.3 | 62 | 3376 | 6.17 | 6.26 | 3.81 |
| 1 | Good | G | VVS1 | 63.8 | 60 | 7134 | 6.35 | 6.31 | 4.04 |
| 0.31 | Very Good | F | VS1 | 60.9 | 56 | 675 | 4.37 | 4.38 | 2.66 |
| 0.4 | Very Good | D | SI2 | 61.6 | 59 | 666 | 4.68 | 4.74 | 2.90 |
| 0.7 | Very Good | E | VS1 | 63.8 | 57 | 3177 | 5.61 | 5.65 | 3.59 |
| 0.3 | Premium | H | VS1 | 63.0 | 58 | 675 | 4.28 | 4.23 | 2.68 |
| 0.4 | Premium | E | VS1 | 62.4 | 54 | 1125 | 4.75 | 4.71 | 2.95 |
| 0.3 | Premium | F | VVS2 | 61.6 | 58 | 737 | 4.28 | 4.35 | 2.66 |
| 1 | Ideal | D | VS1 | 62.4 | 55 | 7966 | 6.40 | 6.43 | 4.00 |
| 0.41 | Ideal | F | VVS1 | 62.0 | 55 | 1295 | 4.74 | 4.78 | 2.95 |
| 1.57 | Ideal | G | VVS2 | 62.3 | 56 | 15144 | 7.48 | 7.41 | 4.64 |
Another function is formattable() in the
formattable package. The default table is reasonable.
d %>%
formattable::formattable()
| carat | cut | color | clarity | depth | table | price | x | y | z |
|---|---|---|---|---|---|---|---|---|---|
| 0.70 | Fair | F | SI2 | 66.4 | 56 | 1564 | 5.51 | 5.42 | 3.63 |
| 2.10 | Fair | G | I1 | 64.6 | 58 | 6597 | 8.05 | 8.01 | 5.19 |
| 1.00 | Fair | E | SI2 | 65.8 | 58 | 2948 | 6.28 | 6.16 | 4.09 |
| 0.50 | Good | G | VVS2 | 63.8 | 56 | 1715 | 5.03 | 5.06 | 3.22 |
| 0.93 | Good | F | SI2 | 61.3 | 62 | 3376 | 6.17 | 6.26 | 3.81 |
| 1.00 | Good | G | VVS1 | 63.8 | 60 | 7134 | 6.35 | 6.31 | 4.04 |
| 0.31 | Very Good | F | VS1 | 60.9 | 56 | 675 | 4.37 | 4.38 | 2.66 |
| 0.40 | Very Good | D | SI2 | 61.6 | 59 | 666 | 4.68 | 4.74 | 2.90 |
| 0.70 | Very Good | E | VS1 | 63.8 | 57 | 3177 | 5.61 | 5.65 | 3.59 |
| 0.30 | Premium | H | VS1 | 63.0 | 58 | 675 | 4.28 | 4.23 | 2.68 |
| 0.40 | Premium | E | VS1 | 62.4 | 54 | 1125 | 4.75 | 4.71 | 2.95 |
| 0.30 | Premium | F | VVS2 | 61.6 | 58 | 737 | 4.28 | 4.35 | 2.66 |
| 1.00 | Ideal | D | VS1 | 62.4 | 55 | 7966 | 6.40 | 6.43 | 4.00 |
| 0.41 | Ideal | F | VVS1 | 62.0 | 55 | 1295 | 4.74 | 4.78 | 2.95 |
| 1.57 | Ideal | G | VVS2 | 62.3 | 56 | 15144 | 7.48 | 7.41 | 4.64 |
d %>%
# Conditional highlighting
mutate(
carat = cell_spec(carat, "html", color = ifelse(carat > .7, "red", "black")),
price = cell_spec(price, "html", color = ifelse(price < 5000, "blue", "black"))
) %>%
formattable::formattable(
list(
# Width depends on proportion from 0 to max value
x = color_bar("#C8102E"),
y = color_bar("#C8102E"),
z = color_bar("#C8102E"),
# Color depends on proportion from min to max value
depth = color_tile("#CAC7A7","#524727")
)
)
| carat | cut | color | clarity | depth | table | price | x | y | z |
|---|---|---|---|---|---|---|---|---|---|
| 0.7 | Fair | F | SI2 | 66.4 | 56 | 1564 | 5.51 | 5.42 | 3.63 |
| 2.1 | Fair | G | I1 | 64.6 | 58 | 6597 | 8.05 | 8.01 | 5.19 |
| 1 | Fair | E | SI2 | 65.8 | 58 | 2948 | 6.28 | 6.16 | 4.09 |
| 0.5 | Good | G | VVS2 | 63.8 | 56 | 1715 | 5.03 | 5.06 | 3.22 |
| 0.93 | Good | F | SI2 | 61.3 | 62 | 3376 | 6.17 | 6.26 | 3.81 |
| 1 | Good | G | VVS1 | 63.8 | 60 | 7134 | 6.35 | 6.31 | 4.04 |
| 0.31 | Very Good | F | VS1 | 60.9 | 56 | 675 | 4.37 | 4.38 | 2.66 |
| 0.4 | Very Good | D | SI2 | 61.6 | 59 | 666 | 4.68 | 4.74 | 2.90 |
| 0.7 | Very Good | E | VS1 | 63.8 | 57 | 3177 | 5.61 | 5.65 | 3.59 |
| 0.3 | Premium | H | VS1 | 63.0 | 58 | 675 | 4.28 | 4.23 | 2.68 |
| 0.4 | Premium | E | VS1 | 62.4 | 54 | 1125 | 4.75 | 4.71 | 2.95 |
| 0.3 | Premium | F | VVS2 | 61.6 | 58 | 737 | 4.28 | 4.35 | 2.66 |
| 1 | Ideal | D | VS1 | 62.4 | 55 | 7966 | 6.40 | 6.43 | 4.00 |
| 0.41 | Ideal | F | VVS1 | 62.0 | 55 | 1295 | 4.74 | 4.78 | 2.95 |
| 1.57 | Ideal | G | VVS2 | 62.3 | 56 | 15144 | 7.48 | 7.41 | 4.64 |
As we will see, with the pagination, datatable()
provides the capability to succinctly display much larger tables. So we
will use more data
set.seed(20230416)
d <- diamonds %>%
sample_n(1000)
A basic interactive table using DT::datatable().
DT::datatable(d)
Many options can be added
DT::datatable(d, rownames = FALSE, filter = "top")
DT::datatable(d, rownames = FALSE,
editable = TRUE,
extensions = "Buttons",
options = list(
dom = "Bfrtip",
buttons = c("copy","csv","excel","pdf","print")
))
Here is a static plot of the diamonds data set.
d <- diamonds %>% sample_n(1000)
g <- ggplot(d,
aes(
x = carat,
y = price,
shape = cut,
color = color)) +
geom_point() +
scale_y_log10() +
scale_x_log10(breaks = scales::breaks_pretty())
g
## Warning: Using shapes for an ordinal variable is not advised
ggplotly(g)
## Warning: Using shapes for an ordinal variable is not advised
g <- ggplot(case0501, aes(x = Diet, y = Lifetime)) +
geom_boxplot() +
coord_flip()
ggplotly(g)
g <- ggplot(diamonds, aes(x = price)) +
geom_histogram(bins = 100)
ggplotly(g)
Another package from constructing interactive graphics is dygraphs.
Example taken from here.
leaflet::leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 17) %>%
addPopups(
-93.65, 42.0285,
'Here is the <b>Department of Statistics</b>, ISU'
)
gibbs_bivariate_normal = function(theta0, n_points, rho) {
theta = matrix(theta0, nrow=n_points, ncol=2, byrow=TRUE)
v = sqrt(1-rho^2)
for (i in 2:n_points) {
theta[i,1] = rnorm(1, rho*theta[i-1,2], v)
theta[i,2] = rnorm(1, rho*theta[i ,1], v)
}
return(theta)
}
theta = gibbs_bivariate_normal(c(-3,3), n<-20, rho=rho<-0.9)
bivariate_normal_animation = function(x, rho, ask=interactive()) {
# Create contour plot
n.out = 101
xx <- seq(-3, 3, length=n.out)
grid <- expand.grid(x=xx, y=xx)
Sigma = diag(rep(.1,2))+rho
like <- matrix(apply(grid, 1, function(x) mvtnorm::dmvnorm(x,sigma=Sigma)),n.out,n.out)
for (i in 2:nrow(x)) {
jj = (2:i)[-(i-1)] # vector from 2:(i-1) and NULL if i=2
for (j in 1:6) {
plot.new()
# All previous plotting
contour(xx, xx, like, drawlabels=F, nlevels=10, xlim=c(-3,3), ylim=c(-3,3),
xlab=expression(theta[1]), ylab=expression(theta[2]))
segments(x[jj-1,1], x[jj-1,2], x[jj,1], x[jj-1,2], col="gray")
segments(x[jj ,1], x[jj-1,2], x[jj,1], x[jj ,2], col="gray")
points(x[(1:(i-1)),1], x[(1:(i-1)),2], col="red", pch=19)
# New plotting
if (j>1 & j<4) abline(h=x[i-1,2], lty=2)
if (j>2) arrows(x[i-1,1], x[i-1,2], x[i,1], x[i-1,2], length=0.1)
if (j>3 & j<6) abline(v=x[i,1], lty=2)
if (j>4) arrows(x[i,1], x[i-1,2], x[i,1], x[i,2], length=0.1)
if (j>5) points(x[i,1], x[i,2], col="red", pch=19)
if (ask) readline("hit <enter>:")
}
}
jj=2:nrow(x)
contour(xx, xx, like, drawlabels=F, nlevels=10, xlim=c(-3,3), ylim=c(-3,3),
xlab=expression(theta[1]), ylab=expression(theta[2]))
segments(x[jj-1,1], x[jj-1,2], x[jj,1], x[jj-1,2], col="gray")
segments(x[jj ,1], x[jj-1,2], x[jj,1], x[jj ,2], col="gray")
points(x[,1], x[,2], col="red", pch=19)
}
bivariate_normal_animation(theta, rho = 0.9)
Official:
Individuals: